home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / MISC.SWG / 0124_Extract File Descriptions from BBS files.pas < prev    next >
Pascal/Delphi Source File  |  1995-02-28  |  22KB  |  524 lines
  1. {$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X-,Y-}
  2. {$M 16384,0,655360}
  3. {$DEFINE Kort}
  4. Program Extract;
  5.   { extract filenames and accompanying descriptions from bbs files listings }
  6.   { Author: Eddy Thilleman, 19 mei 1994 }
  7.   { written in Borland Pascal version 7.01 }
  8.   {  modified: augustus 1994 - choose between long vs. short directory name }
  9.   {  modified: januari  1995 - keep only filenames with entries found on screen
  10.                              - total number of found entries
  11.                              - delete destination directory if no entries found }
  12.  
  13. Uses
  14.   Dos;
  15.  
  16. Type
  17.   TypeNotAllowed = set of char;  { filter out (some) header lines }
  18. Const
  19.   NotAllowed : TypeNotAllowed = [''..' ','*',':'..'?','|','░'..'▀'];
  20.   NoFAttr : word =   $1C;  { dir-, volume-, system attributen }
  21.   FAttr   : word =   $23;  { readonly-, hidden-, archive attributes }
  22.   BufSizeBig     = 49152;  { 48 KB }
  23.   BufSizeSmall   =  8192;  {  8 KB }
  24.   Cannot         = 'Cannot create destination ';
  25.   MaxNrLines     =    20;  { max # of lines for one entry }
  26.   MaxNrSearch    =    18;  { max # of words to search for }
  27.  
  28. Type
  29.   BufTypeSource  = array [1..BufSizeBig  ] of char;
  30.   BufTypeDest    = array [1..BufSizeSmall] of char;
  31.   string3        = string[03];
  32.   String12       = string[12];
  33.   String16       = string[16];
  34.   String25       = string[25];
  35.   String65       = string[65];
  36.   TypeLine       = array [1..MaxNrLines] of string;
  37.  
  38. Var
  39.   Line             : TypeLine;         { filename and description  }
  40.   Tmp1, Tmp2       : string;           { temporary hold lines here }
  41.   FileName         : String12;         { filename in files listing }
  42.   SearchText       : array [1..MaxNrSearch] of String65;
  43.   Count, TotalCount: word;             { # of found entries        }
  44.   SourceFile, DestFile : text;         { sourcefile and dest. file }
  45.   SourceBuf        : BufTypeSource;    { source text buffer        }
  46.   DestBuf          : BufTypeDest;      { destination text buffer   }
  47. {$IFDEF Kort}
  48.   DestListing      : string16;         { name of destination file  }
  49.   DestDir          : string3 ;         { name of destination directory }
  50. {$ELSE}
  51.   DestListing      : string25;         { name of destination file  }
  52.   DestDir          : string12;         { name of destination directory }
  53. {$ENDIF}
  54.   FR               : SearchRec;        { FileRecord }
  55.   FMask, DirName   : String12;
  56.   Exists           : boolean;
  57.   nr,                                  { nr: points to element# where
  58.                                              to put the next read-in line   }
  59.   NrLines          : byte;             { NrLines: number of lines belonging
  60.                                              to this entry }
  61.   found, Header    : boolean;
  62.   T                : byte;             { points to char in line: allowed? }
  63.   NrSearch,                            { current word to search for       }
  64.   TotalNrSearch    : byte;             { total # of words to search for   }
  65.  
  66.  
  67. procedure LowerFast( var Str: String );
  68.   { 52 Bytes by Bob Swart, 11-6-1993, '80XXX' FASTEST! }
  69. InLine(
  70.   $8C/$DA/               {       mov   DX,DS                 }
  71.   $BB/Ord('A')/
  72.       Ord('Z')-Ord('A')/ {       mov   BX,'Z'-'A'/'A'        }
  73.   $5E/                   {       pop   SI                    }
  74.   $1F/                   {       pop   DS                    }
  75.   $FC/                   {       cld                         }
  76.   $AC/                   {       lodsb                       }
  77.   $88/$C1/               {       mov   CL,AL                 }
  78.   $30/$ED/               {       xor   CH,CH                 }
  79.   $D1/$E9/               {       shr   CX,1                  }
  80.   $73/$0B/               {       jnc   @Part1                }
  81.   $AC/                   {       lodsb                       }
  82.   $28/$D8/               {       sub   AL,BL                 }
  83.   $38/$F8/               {       cmp   AL,BH                 }
  84.   $77/$04/               {       ja    @Part1                }
  85.   $80/$44/$FF/
  86.       Ord('a')-Ord('A')/ {@Loop: ADD   Byte Ptr[SI-1],'a'-'A'}
  87.   $E3/$14/               {@Part1:jcxz  @Exit                 }
  88.   $AD/                   {       lodsw                       }
  89.   $28/$D8/               {       sub   AL,BL                 }
  90.   $38/$F8/               {       cmp   AL,BH                 }
  91.   $77/$04/               {       ja    @Part2                }
  92.   $80/$44/$FE/
  93.       Ord('a')-Ord('A')/ {       ADD   Byte Ptr[SI-2],'a'-'A'}
  94.   $49/                   {@Part2:dec   CX                    }
  95.   $28/$DC/               {       sub   AH,BL                 }
  96.   $38/$FC/               {       cmp   AH,BH                 }
  97.   $77/$EC/               {       ja    @Part1                }
  98.   $EB/$E6/               {       jmp   @Loop                 }
  99.   $8E/$DA                {@Exit: mov   DS,DX                 }
  100. ) { LowerFast };
  101.  
  102.  
  103. procedure CopySubStr( Str1: string; start, nrchars: byte; var Str2: string );
  104. assembler;
  105.   { copy part of Str1 (beginning at start for nrchars) to Str2
  106.     if start > length of Str1, Str2 will contain a empty string.
  107.     if nrchars specifies more characters than remain starting at the
  108.     start position, Str2 will contain just that remainder of Str1. }
  109. asm     { setup }
  110.         lds   si, str1     { load in DS:SI pointer to str1 }
  111.         cld                { string operations forward     }
  112.         les   di, str2     { load in ES:DI pointer to str2 }
  113.         mov   ah, [si]     { length str1 --> AH            }
  114.         and   ah, ah       { length str1 = 0?              }
  115.         je    @null        { yes, empty string in Str2     }
  116.         mov   bl, [start]  { starting position --> BL      }
  117.         cmp   ah, bl       { start > length str1?          }
  118.         jb    @null        { yes, empty string in Str2     }
  119.  
  120.         { start + nrchars - 1 > length str1?               }
  121.         mov   al, [nrchars]{ nrchars --> AL                }
  122.         mov   dh, al       { nrchars --> DH                }
  123.         add   dh, bl       { add start                     }
  124.         dec   dh
  125.         cmp   ah, dh       { nrchars > rest of str1?       }
  126.         jb    @rest        { yes, copy rest of str1        }
  127.         jmp   @copy
  128. @null:  xor   ax, ax       { return a empty string         }
  129.         jmp   @done
  130. @rest:  sub   ah, bl       { length str1 - start           }
  131.         inc   ah
  132.         mov   al, ah
  133. @copy:  mov   cl, al       { how many chars to copy        }
  134.         xor   ch, ch       { clear CH                      }
  135.         xor   bh, bh       { clear BH                      }
  136.         add   si, bx       { starting position             }
  137.         mov   dx, di       { save pointer to str2          }
  138.         inc   di
  139.     rep movsb              { copy part str1 to str2        }
  140.         mov   di, dx       { restore pointer to str2       }
  141. @done:  mov   [di], al     { overwrite length byte of str2 }
  142. @exit:
  143. end  { CopySubStr };
  144.  
  145.  
  146. procedure StrCopy( var Str1, Str2: string ); assembler;
  147.   { copy str1 to str2 }
  148. asm
  149.         lds   si, str1     { load in DS:SI pointer to str1 }
  150.         cld                { string operations forward     }
  151.         les   di, str2     { load in ES:DI pointer to str2 }
  152.         xor   ch, ch       { clear CH                      }
  153.         mov   cl, [si]     { length str1 --> CX            }
  154.         inc   cx           { include length byte           }
  155.     rep movsb              { copy str1 to str2             }
  156. @exit:
  157. end  { StrCopy };
  158.  
  159.  
  160. function StrPos( var str1, str2: string ): byte; assembler;
  161.   { returns position of the first occurrence of str1 in str2 }
  162.   { str1 - string to search for }
  163.   { str2 - string to search in  }
  164.   { return value in AX }
  165. asm
  166.         cld                 { string operations forward                 }
  167.         les   di, str2      { load in ES:DI pointer to str2             }
  168.         xor   cx, cx        { clear cx                                  }
  169.         mov   cl, [di]      { length str2 --> CL                        }
  170.         jcxz  @not          { if length str2 = 0, nothing to search in  }
  171.         mov   bh, cl        { length str2 --> BH                        }
  172.         inc   di            { di point to 1st char of str2              }
  173.         lds   si, str1      { load in DS:SI pointer to str1             }
  174.         lodsb               { load in AL length str1                    }
  175.         and   al, al        { length str1 = 0?                          }
  176.         jz    @not          { length str1 = 0, nothing to search for    }
  177.         dec   al            { 1st char need not be compared again       }
  178.         sub   cl, al        { length str2 - length str1                 }
  179.         jbe   @not          { length str2 < length str1                 }
  180.         mov   ah, al        { length str1 --> AH                        }
  181.         lodsb               { load in AL 1st character of str1          }
  182. @start:
  183.   repne scasb               { scan for next occurrence 1st char in str2 }
  184.         jne   @not          { no success                                }
  185.         mov   dx, si        { pointer to 2nd char in str1 --> DX        }
  186.         mov   bl, cl        { number of chars in str2 to go --> BL      }
  187.         mov   cl, ah        { length str1 --> CL                        }
  188.    repe cmpsb               { compare until characters don't match      }
  189.         je    @pos          { full match                                }
  190.         sub   si, dx        { current SI - prev. SI = # of chars moved  }
  191.         sub   di, si        { current DI - # of chars moved = prev. DI  }
  192.         mov   si, dx        { restore pointer to 2nd char in str1       }
  193.         mov   cl, bl        { number of chars in str2 to go --> BL      }
  194.         jmp   @start        { scan for next occurrence 1st char in str2 }
  195. @not:   xor   ax, ax        { str1 is not in str2, result 0             }
  196.         jmp   @exit
  197. @pos:   add   bl, ah        { number of chars in str2 left              }
  198.         mov   al, bh        { length str2 --> AX                        }
  199.         sub   al, bl        { start position of str1 in str2            }
  200. @exit:                      { we are finished. }
  201. end  { StrPos };
  202.  
  203.  
  204. procedure Trim( var Str: string ); assembler;
  205.   { remove leading and trailing white space from str }
  206.   { white space = all ASCII chars 0h - 20h }
  207. asm     { setup }
  208.         lds   si, str        { load in DS:SI pointer to Str       }
  209.         xor   cx, cx         { clear cx                           }
  210.         mov   cl, [si]       { length Str --> cx                  }
  211.         jcxz  @exit          { if length Str = 0, exit            }
  212.         mov   bx, si         { save pointer to length byte of Str }
  213.         add   si, cx         { last character                     }
  214.  
  215.         { look for trailing space }
  216. @loop1: mov   al, [si]       { load character                     }
  217.         cmp   al, ' '        { no white space                     }
  218.         ja    @stop1         { first non-blank character found    }
  219.         dec   si             { next character                     }
  220.         dec   cx             { count down                         }
  221.         jcxz  @done          { if no more characters left, done   }
  222.         jmp   @loop1         { try again                          }
  223. @stop1: mov   si, bx         { point to start of Str              }
  224.         inc   si             { point to 1st character             }
  225.         mov   di, si         { pointer to Str --> DI              }
  226.         { look for leading white space }
  227. @loop2: mov   al, [si]       { load character                     }
  228.         cmp   al, ' '        { no white space                     }
  229.         ja    @stop2         { first non-blank character found    }
  230.         inc   si             { next character                     }
  231.         dec   cx             { count down                         }
  232.         jcxz  @done          { if no more characters left, done   }
  233.         jmp   @loop2         { try again                          }
  234.  
  235.         { remove leading white space }
  236. @stop2: cld                  { string operations forward          }
  237.         mov   dx, cx         { save new length Str                }
  238.     rep movsb                { move remaining part of Str         }
  239.         mov   cx, dx         { restore new length Str             }
  240. @done:  mov   [bx], cl       { new length of Str                  }
  241. @exit:
  242. end  { Trim };
  243.  
  244.  
  245. function InSet25(var _Set; OrdElement: Byte): Boolean;
  246.   { I got this function from Bob Swart }
  247. InLine(
  248.   $58/         {   pop   AX                   }
  249.   $30/$E4/     {   xor   AH,AH                }
  250.   $5F/         {   pop   DI                   }
  251.   $07/         {   pop   ES                   }
  252.   $89/$C3/     {   mov   BX,AX                }
  253.   $B1/$03/     {   mov   CL,3                 }
  254.   $D3/$EB/     {   shr   BX,CL                }
  255.   $88/$C1/     {   mov   CL,AL                }
  256.   $80/$E1/$07/ {   and   CL,$07               }
  257.   $B0/$01/     {   mov   AL,1                 }
  258.   $D2/$E0/     {   shl   AL,CL                }
  259.   $26/         {   ES:                        }
  260.   $22/$01/     {   and   AL,BYTE PTR [DI+BX]  }
  261.   $D2/$E8);    {   shr   AL,CL                }
  262. { InSet25 }
  263.  
  264.  
  265. function OpenTextFile (var InF: text; const name: string; var buffer: BufTypeSource): boolean;
  266. begin
  267.   Assign( InF, Name );
  268.   SetTextBuf( InF, buffer );
  269.   Reset( InF );
  270.   OpenTextFile := (IOResult = 0);
  271. end  { OpenTextFile };
  272.  
  273. function CreateTextFile (var OutF: text; const name: string; var buffer: BufTypeDest): boolean;
  274. begin
  275.   Assign( OutF, Name );
  276.   SetTextBuf( OutF, buffer );
  277.   Rewrite( OutF );
  278.   CreateTextFile := (IOResult = 0);
  279. end  { CreateTextFile };
  280.  
  281. function Exist( Name : string ) : Boolean;
  282.   { Return true if directory or file with the same name is found}
  283. var
  284.   F    : file;
  285.   Attr : Word;
  286. begin
  287.   Assign( F, Name );
  288.   GetFAttr( F, Attr );
  289.   Exist := (DosError = 0)
  290. end;
  291.  
  292. {$IFDEF Kort}
  293. procedure UniekeEntry( var Naam : string3 );
  294. const
  295.   max    = $39;  { '0'..'9' = $30..$39 }
  296. var
  297.   Nbyte  : array [0..3] of byte absolute Naam;
  298.   Exists : boolean;
  299.  
  300. begin
  301.   Nbyte [0] := 3;  { FileName of 3 characters }
  302.  
  303.   Exists := True;
  304.   Nbyte [1] := $30;
  305.   while (Nbyte [1] <= max) and Exists do begin
  306.     Nbyte [2] := $30;
  307.     while (Nbyte [2] <= max) and Exists do begin
  308.       Nbyte [3] := $30;
  309.       while (Nbyte [3] <= max) and Exists do begin
  310.         Exists := Exist( Naam );
  311.         if Exists then inc( Nbyte [3] );
  312.       end;
  313.       if Exists then inc( Nbyte [2] );
  314.     end;
  315.     if Exists then inc( Nbyte [1] );
  316.   end;
  317. end;  { end procedure UniekeEntry }
  318.  
  319. {$ELSE}
  320. procedure UniekeEntry( var Naam : string12 );
  321. const
  322.   max    = $39;  { '0'..'9' = $30..$39 }
  323. var
  324.   Nbyte  : array [0..12] of byte absolute Naam;
  325.   Exists : boolean;
  326.  
  327. begin
  328.   Nbyte [0] := 12;  { FileName of 12 characters (8+3+".") }
  329.   Nbyte [9] := $2E; { '.' as 9e character }
  330.  
  331.   Exists := True;
  332.   Nbyte [1] := $30;
  333.   while (Nbyte [1] <= max) and Exists do begin
  334.     Nbyte [2] := $30;
  335.     while (Nbyte [2] <= max) and Exists do begin
  336.       Nbyte [3] := $30;
  337.       while (Nbyte [3] <= max) and Exists do begin
  338.         Nbyte [4] := $30;
  339.         while (Nbyte [4] <= max) and Exists do begin
  340.           Nbyte [5] := $30;
  341.           while (Nbyte [5] <= max) and Exists do begin
  342.             Nbyte [6] := $30;
  343.             while (Nbyte [6] <= max) and Exists do begin
  344.               Nbyte [7] := $30;
  345.               while (Nbyte [7] <= max) and Exists do begin
  346.                 Nbyte [8] := $30;
  347.                 while (Nbyte [8] <= max) and Exists do begin
  348.                   Nbyte [10] := $30;
  349.                   while (Nbyte [10] <= max) and Exists do begin
  350.                     Nbyte [11] := $30;
  351.                     while (Nbyte [11] <= max) and Exists do begin
  352.                       Nbyte [12] := $30;
  353.                       while (Nbyte [12] <= max) and Exists do begin
  354.                         Exists := Exist( Naam );
  355.                         if Exists then inc( Nbyte [12] );
  356.                       end;
  357.                       if Exists then inc( Nbyte [11] );
  358.                     end;
  359.                     if Exists then inc( Nbyte [10] );
  360.                   end;
  361.                   if Exists then inc( Nbyte [8] );
  362.                 end;
  363.                 if Exists then inc( Nbyte [7] );
  364.               end;
  365.               if Exists then inc( Nbyte [6] );
  366.             end;
  367.             if Exists then inc( Nbyte [5] );
  368.           end;
  369.           if Exists then inc( Nbyte [4] );
  370.         end;
  371.         if Exists then inc( Nbyte [3] );
  372.       end;
  373.       if Exists then inc( Nbyte [2] );
  374.     end;
  375.     if Exists then inc( Nbyte [1] );
  376.   end;
  377. end;  { end procedure UniekeEntry }
  378. {$ENDIF}
  379.  
  380.  
  381. procedure Search;
  382. begin
  383.   found := False;
  384.   NrSearch := 1;
  385.   while (NrSearch <= TotalNrSearch) and not found do
  386.   begin
  387.     nr := 1;
  388.     while (nr <= NrLines) and not found do
  389.     begin                                { search wanted text    }
  390.       StrCopy( Line[nr], Tmp1 );
  391.       LowerFast( Tmp1 );                 { convert to lower case }
  392.       if StrPos( SearchText[NrSearch], Tmp1 ) > 0 then found := True;
  393.       inc( nr );
  394.     end;
  395.     inc( NrSearch );
  396.   end;
  397.   if found then                      { at least one of the wanted words found }
  398.   begin
  399.     for nr := 1 to NrLines do WriteLn( DestFile, Line[nr] );
  400.     inc( Count );
  401.   end;
  402. end;
  403.  
  404.  
  405. procedure Process( var SourceListing : string12 );
  406. begin
  407.   Count := 0;
  408.   DestListing  := DestDir + '\' + SourceListing;
  409.   if OpenTextFile( SourceFile, SourceListing, SourceBuf ) then
  410.   begin
  411.     if CreateTextFile( DestFile, DestListing, DestBuf ) then
  412.     begin
  413.       write( SourceListing:12 );
  414.       Header   := False;
  415.       FileName := '';
  416.       NrLines  := 0;
  417.       nr := 1;
  418.       ReadLn( SourceFile, Line[nr] );
  419.       while not Eof(SourceFile) and (IOResult = 0) do
  420.       begin
  421.         StrCopy( Line[nr], Tmp1 );
  422.         Trim( Tmp1 );
  423.         if Length( Tmp1 ) > 0 then                  { no empty lines }
  424.         begin
  425.           CopySubStr( Line[nr], 1, 12, FileName );
  426.           Trim( FileName );
  427.           T := 1;
  428.           while (T <= Length( FileName ))
  429.           and not InSet25( NotAllowed, Byte( FileName[T] ) ) do
  430.             inc( T );                               { look out for headers }
  431.           { }
  432.           Header := (T <= Length( FileName ))
  433.             or ((Length( FileName ) > 0) and (Line[nr][1]=' '));  { header? }
  434.           if Header then
  435.             FileName := ''                          { read next line }
  436.           else                                      { no header }
  437.           begin
  438.             if (Length( FileName ) = 0) then        { more description }
  439.             begin
  440.               inc( nr );
  441.               inc( NrLines );
  442.             end
  443.             else
  444.             begin
  445.               StrCopy( Line[nr], Tmp2 );     { save new textline    }
  446.               Search;
  447.  
  448.               { setup for next entry }
  449.               NrLines  := 1;                 { already got one line }
  450.               nr       := 2;                 { so next line in #2   }
  451.               StrCopy( Tmp2, Line[1] );      { restore new textline }
  452.               FileName := '';                { make sure a new line is read }
  453.             end;  { endif (Length( FileName ) = 0)) }
  454.           end;  { if Header }
  455.         end;  { if Length( Tmp1 ) > 0 }
  456.         if (Length( FileName ) = 0) then
  457.           ReadLn( SourceFile, Line[nr] );
  458.         { }
  459.       end;  { while not Eof(SourceFile) and (IOResult = 0) }
  460.       inc( NrLines );   { include the last line in the search }
  461.       Search;
  462.       Close( DestFile );
  463.       if (Count = 0) then
  464.       begin
  465.         Erase( DestFile );
  466.         Write( #13 );
  467.       end
  468.       else
  469.       begin
  470.         writeln( Count:7, ' in ', DestListing );
  471.         TotalCount := TotalCount + Count;
  472.       end
  473.     end  { if CreateTextFile }
  474.     else
  475.       writeln( Cannot, 'file ', DestListing );
  476.     { }
  477.     Close( SourceFile );
  478.   end   { if OpenTextFile }
  479.   else
  480.     writeln( 'Cannot open sourcefile ', SourceListing );
  481.   { }
  482. end;
  483.  
  484.  
  485. begin
  486.   if ParamCount > 1 then                 { parameters: listing catchwords  }
  487.   begin
  488.     TotalCount := 0;
  489.     TotalNrSearch := ParamCount - 1;
  490.     if (TotalNrSearch > MaxNrSearch) then
  491.       TotalNrSearch := MaxNrSearch;      { no more catchwords than maximum }
  492.     UniekeEntry( DestDir );
  493.     if not Exists then
  494.     begin
  495.       MkDir( DestDir );
  496.       if (IOResult=0) then
  497.       begin
  498.         Write( 'Searching:' );
  499.         FMask        := ParamStr( 1 );                    { filemask       }
  500.         for NrSearch := 1 to TotalNrSearch do             { all catchwords }
  501.         begin
  502.           SearchText[NrSearch] := ParamStr( NrSearch+1 ); { each catchword }
  503.           LowerFast( SearchText[NrSearch] );     { translate to lower case }
  504.           Write(' ', SearchText[NrSearch] );
  505.         end;
  506.         WriteLn;
  507.         FindFirst(FMask, FAttr, FR);
  508.         while DosError = 0 do
  509.         begin
  510.           Process(FR.Name);
  511.           FindNext(FR);
  512.         end;
  513.         WriteLn( 'Total found ', TotalCount, ' entries.' );
  514.         if (TotalCount = 0) then RmDir( DestDir );
  515.       end;  { if not IOResult }
  516.     end   { if not Exists }
  517.     else
  518.       writeln( Cannot, 'directory ', DestListing );
  519.     { }
  520.   end   { if ParamCount > 1 }
  521.   else
  522.     WriteLn( 'Extract filename word(s)' );
  523. end.
  524.